home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / swagd_f.zip / EGAVGA.SWG / 0065_PLASMA Fractal.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-02  |  4KB  |  181 lines
  1. {
  2. >Do you have Pascal code For generating this PLAsmA fractal? if so,
  3. >then I'd like to snarf a copy of it, if'n you don't mind... Or (if it's
  4. >not too large) could you post it as a message? Thanx in advance!
  5. }
  6.  
  7. Program PlAsma;
  8.  
  9. Uses
  10.   Crt, Dos;
  11.  
  12. Const
  13.   f = 2.0;
  14.   EndProgram  : Boolean = False;
  15.   DelayFactor : Byte    = 20;
  16.  
  17. Type
  18.   ColorValue  = Record
  19.     Rvalue,
  20.     Gvalue,
  21.     Bvalue : Byte;
  22.   end;
  23.  
  24.   PaletteType = Array [0..255] of ColorValue;
  25.  
  26. Var
  27.   ch    : Char;
  28.   i     : Integer;
  29.   image : File;
  30.   ok    : Boolean;
  31.   p     : paletteType;
  32.  
  33. Procedure SetVGApalette(Var tp : PaletteType);
  34. Var
  35.   regs : Registers;
  36. begin
  37.   With regs do
  38.   begin
  39.     AX := $1012;
  40.     BX := 0;
  41.     CX := 256;
  42.     ES := Seg(tp);
  43.     DX := Ofs(tp);
  44.   end;
  45.   Intr($10, regs);
  46. end;
  47.  
  48. Procedure PutPixel(x, y : Integer; c : Byte);
  49. begin
  50.   mem[$a000 : Word(320 * y + x)] := c;
  51. end;
  52.  
  53. Function GetPixel(x, y : Integer) : Byte;
  54. begin
  55.   GetPixel := mem[$a000 : Word(320 * y + x)];
  56. end;
  57.  
  58. Procedure adjust(xa, ya, x, y, xb, yb : Integer);
  59. Var
  60.   d, v : Integer;
  61. begin
  62.   if GetPixel(x, y) <> 0 then
  63.     Exit;
  64.   d := abs(xa - xb) + abs(ya - yb);
  65.   v := trunc((GetPixel(xa, ya) + GetPixel(xb, yb)) / 2 +
  66.        (random - 0.5) * d * F);
  67.   if v < 1 then
  68.     v := 1;
  69.   if v >= 193 then
  70.     v := 192;
  71.   putpixel(x, y, v);
  72. end;
  73.  
  74. Procedure subDivide(x1, y1, x2, y2 : Integer);
  75. Var
  76.   x, y : Integer;
  77.   v    : Real;
  78. begin
  79.   if KeyPressed then
  80.     Exit;
  81.   if (x2 - x1 < 2) and (y2 - y1 < 2) then
  82.     Exit;
  83.   x := (x1 + x2) div 2;
  84.   y := (y1 + y2) div 2;
  85.   adjust(x1, y1, x, y1, x2, y1);
  86.   adjust(x2, y1, x2, y, x2, y2);
  87.   adjust(x1, y2, x, y2, x2, y2);
  88.   adjust(x1, y1, x1, y, x1, y2);
  89.   if GetPixel(x, y) = 0 then
  90.   begin
  91.     v := (GetPixel(x1, y1) + GetPixel(x2, y1) + GetPixel(x2, y2) +
  92.           getPixel(x1, y2)) / 4;
  93.     putpixel(x, y, Trunc(v));
  94.   end;
  95.  
  96.   SubDivide(x1, y1, x, y);
  97.   subDivide(x, y1, x2, y);
  98.   subDivide(x, y, x2, y2);
  99.   subDivide(x1, y, x, y2);
  100. end;
  101.  
  102. Procedure rotatePalette(Var p : PaletteType; n1, n2, d : Integer);
  103. Var
  104.   q : PaletteType;
  105. begin
  106.   q := p;
  107.   For i := n1 to n2 do
  108.     p[i] :=q[n1 + (i + d) mod (n2 - n1 + 1)];
  109.   SetVGApalette(p);
  110. end;
  111.  
  112. begin
  113.   Inline($b8/$13/0/$cd/$10);
  114.   With P[0] do
  115.   begin
  116.     Rvalue := 32;
  117.     Gvalue := 32;
  118.     Bvalue := 32;
  119.   end;
  120.   For i := 0 to 63 do
  121.   begin
  122.     With p[i + 1] do
  123.     begin
  124.       Rvalue := 63-i; { 63 - i }
  125.       Gvalue := 63-i; { 63 - i }
  126.       Bvalue := i+63;    { 0 }
  127.     end;
  128.     With p[i + 65] do
  129.     begin
  130.       Rvalue := 0;    { 0 }
  131.       Gvalue := i+63;    { i }
  132.       Bvalue := 63-i;    { 0 }
  133.     end;
  134.     With p[i + 129] do
  135.     begin
  136.       Rvalue := i;    { 0 }
  137.       Gvalue := i;    { 0 }
  138.       Bvalue := 63 - i; { 63 - i }
  139.     end;
  140.   end;
  141.   Inline($b8/$13/0/$cd/$10);
  142.  
  143.   SetVGApalette(p);
  144.   Assign(image, 'PLASMA.IMG');
  145.   {$i-}
  146.   Reset(image, 1);
  147.   {$I+}
  148.   ok := (ioResult = 0);
  149.   if not ok or (ParamCount <> 0) then
  150.   begin
  151.     Randomize;
  152.     putpixel(0, 0, 1 + Random(192));
  153.     putpixel(319, 0, 1 + Random(192));
  154.     putpixel(319, 199, 1 + Random(192));
  155.     putpixel(0, 199, 1 + Random(192));
  156.     SubDivide(0, 0, 319, 199);
  157.     ReWrite(image, 1);
  158.     BlockWrite(image, mem[$a000:0], $FA00);
  159.   end
  160.   else
  161.     BlockRead(image, mem[$a000:0], $FA00);
  162.  
  163.   Close(image);
  164.   Repeat
  165.     rotatePalette(p, 1, 192, + 1);
  166.     Delay(DelayFactor);
  167.     If KeyPressed then
  168.     Case ReadKey of
  169.       #0 : Case ReadKey of
  170.              #80 : If DelayFactor < 255 then
  171.                      Inc(DelayFactor);
  172.              #72 : If DelayFactor > 0 then
  173.                      Dec(DelayFactor);
  174.            end;
  175.       #113,#81 {Q,q} : EndProgram := True;
  176.     end;
  177.   Until EndProgram;
  178.  
  179.   TextMode(lastmode);
  180. end.
  181.